home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / mips / utils.lisp < prev    next >
Encoding:
Text File  |  1991-11-06  |  2.1 KB  |  81 lines
  1. ;;; -*- Package: MIPS; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: utils.lisp,v 1.1 91/07/26 01:44:45 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; This file contains various useful utilities for generating MIPS code.
  15. ;;;
  16. ;;; Written by William Lott and Christopher Hoover.
  17. ;;; 
  18.  
  19. (in-package "MIPS")
  20.  
  21.  
  22.  
  23. ;;;; Three Way Comparison
  24.  
  25. (defun three-way-comparison (x y condition flavor not-p target temp)
  26.   (ecase condition
  27.     (:eq
  28.      (if not-p
  29.      (inst bne x y target)
  30.      (inst beq x y target)))
  31.     (:lt
  32.      (ecase flavor
  33.        (:unsigned
  34.     (inst sltu temp x y))
  35.        (:signed
  36.     (inst slt temp x y)))
  37.      (if not-p
  38.      (inst beq temp zero-tn target)
  39.      (inst bne temp zero-tn target)))
  40.     (:gt
  41.      (ecase flavor
  42.        (:unsigned
  43.     (inst sltu temp y x))
  44.        (:signed
  45.     (inst slt temp y x)))
  46.      (if not-p
  47.      (inst beq temp zero-tn target)
  48.      (inst bne temp zero-tn target))))
  49.   (inst nop))
  50.  
  51.  
  52. ;;;; Pseudo-atomic support.
  53.  
  54. (defun start-pseudo-atomic ()
  55.   ;; I don't think that we need to clear the interrupted slot.  It should
  56.   ;; be clear already.
  57.   ;(storew zero-tn mutator-tn mutator-pseudo-atomic-interrupted-slot)
  58.   (storew csp-tn mutator-tn mutator-pseudo-atomic-atomic-slot))
  59.  
  60. (defun end-pseudo-atomic (ndescr)
  61.   (let ((label (gen-label)))
  62.     (storew zero-tn mutator-tn mutator-pseudo-atomic-atomic-slot)
  63.     (loadw ndescr mutator-tn mutator-pseudo-atomic-interrupted-slot)
  64.     (inst beq ndescr label)
  65.     (inst nop)
  66.     (inst break pending-interrupt-trap)
  67.     (emit-label label)))
  68.  
  69.  
  70.  
  71. ;;;; write-list support.
  72.  
  73. (defun check-pointer-ages-p (vop value)
  74.   (and (sc-is value descriptor-reg)
  75.        (let ((option (assoc :check-pointer-ages
  76.                 (c::lexenv-options
  77.                  (c::node-lexenv
  78.                   (c::vop-node vop))))))
  79.      (or (null option)
  80.          (cdr option)))))
  81.